PC go! 2008 April

home *** CD-ROM | disk | FTP | other *** search

/ PC go! 2008 April / PCgo 2008-04 (DVD).iso / interface / contents / demoversionen_3846 / 13664 / files / Data1.cab / preview.frm (.txt) < prev next >

Wrap

Visual Basic Form | 2001-10-16 | 24.6 KB | 730 lines

VERSION 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX" Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX" Begin VB.Form frmPreview Caption = "TurboCAD SDK Demo" ClientHeight = 6840 ClientLeft = 3570 ClientTop = 1215 ClientWidth = 8490 LinkTopic = "Form1" PaletteMode = 1 'UseZOrder ScaleHeight = 6840 ScaleWidth = 8490 Begin ComctlLib.Toolbar Toolbar1 Align = 1 'Align Top Height = 465 Left = 0 TabIndex = 11 Top = 0 Width = 8490 _ExtentX = 14975 _ExtentY = 820 ButtonWidth = 741 ButtonHeight = 714 AllowCustomize = 0 'False ImageList = "ImageList1" _Version = 327682 BeginProperty Buttons {0713E452-850A-101B-AFC0-4210102A8DA7} NumButtons = 6 BeginProperty Button1 {0713F354-850A-101B-AFC0-4210102A8DA7} Caption = "" Key = "Circle" Description = "" Object.ToolTipText = "Add Circle" Object.Tag = "" ImageIndex = 1 Style = 2 EndProperty BeginProperty Button2 {0713F354-850A-101B-AFC0-4210102A8DA7} Caption = "" Key = "Line" Description = "" Object.ToolTipText = "Add Line" Object.Tag = "" ImageIndex = 2 Style = 2 EndProperty BeginProperty Button3 {0713F354-850A-101B-AFC0-4210102A8DA7} Caption = "" Key = "Curve" Description = "" Object.ToolTipText = "Add Curve" Object.Tag = "" ImageIndex = 3 Style = 2 EndProperty BeginProperty Button4 {0713F354-850A-101B-AFC0-4210102A8DA7} Caption = "" Key = "Star" Description = "" Object.ToolTipText = "Add Star" Object.Tag = "" ImageIndex = 4 Style = 2 EndProperty BeginProperty Button5 {0713F354-850A-101B-AFC0-4210102A8DA7} Caption = "" Key = "" Description = "" Object.ToolTipText = "" Object.Tag = "" Style = 3 EndProperty BeginProperty Button6 {0713F354-850A-101B-AFC0-4210102A8DA7} Caption = "" Key = "Select" Description = "" Object.ToolTipText = "Select" Object.Tag = "" ImageIndex = 5 Style = 2 EndProperty EndProperty End Begin VB.CommandButton cmdDraw Caption = "Draw" Height = 375 Left = 120 TabIndex = 10 Top = 600 Width = 855 End Begin VB.PictureBox Picture1 Height = 4695 Left = 120 ScaleHeight = 309 ScaleMode = 3 'Pixel ScaleWidth = 533 TabIndex = 9 Top = 1560 Width = 8055 End Begin VB.VScrollBar VScroll1 Height = 4695 LargeChange = 4000 Left = 8160 Max = 32000 SmallChange = 1000 TabIndex = 8 Top = 1560 Width = 255 End Begin VB.HScrollBar HScroll1 Height = 255 LargeChange = 4000 Left = 120 Max = 32000 SmallChange = 1000 TabIndex = 7 Top = 6240 Width = 8055 End Begin VB.ComboBox Combo1 Height = 315 Left = 4560 TabIndex = 5 Top = 600 Width = 3855 End Begin VB.CommandButton cmdProperties Caption = "Properties" Height = 375 Left = 1080 TabIndex = 4 Top = 600 Width = 855 End Begin VB.CommandButton cmdNew Caption = "New Drawing" Height = 375 Left = 3240 TabIndex = 3 Top = 1080 Width = 1215 End Begin VB.CommandButton cmdZoomPlus Caption = "Zoom In" Height = 375 Left = 1080 TabIndex = 2 Top = 1080 Width = 855 End Begin VB.CommandButton cmdZoomMinus Caption = "Zoom Out" Height = 375 Left = 120 TabIndex = 1 Top = 1080 Width = 855 End Begin VB.CommandButton cmdOpen Caption = "Open Drawing" Height = 375 Left = 3240 TabIndex = 0 Top = 600 Width = 1215 End Begin MSComDlg.CommonDialog CommonDialog1 Left = 4800 Top = 960 _ExtentX = 847 _ExtentY = 847 _Version = 393216 Filter = "TurboCAD Files (*.tcw)|*.tcw" End Begin ComctlLib.StatusBar StatusBar1 Align = 2 'Align Bottom Height = 300 Left = 0 TabIndex = 6 Top = 6540 Width = 8490 _ExtentX = 14975 _ExtentY = 529 SimpleText = "" _Version = 327682 BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} NumPanels = 5 BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} AutoSize = 1 Object.Width = 9287 Text = "No drawing" TextSave = "No drawing" Key = "" Object.Tag = "" EndProperty BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7} Object.Width = 1270 MinWidth = 1270 Text = "Left" TextSave = "Left" Key = "" Object.Tag = "" EndProperty BeginProperty Panel3 {0713E89F-850A-101B-AFC0-4210102A8DA7} Object.Width = 1270 MinWidth = 1270 Text = "Top" TextSave = "Top" Key = "" Object.Tag = "" EndProperty BeginProperty Panel4 {0713E89F-850A-101B-AFC0-4210102A8DA7} Object.Width = 1270 MinWidth = 1270 Text = "Width" TextSave = "Width" Key = "" Object.Tag = "" EndProperty BeginProperty Panel5 {0713E89F-850A-101B-AFC0-4210102A8DA7} Object.Width = 1270 MinWidth = 1270 Text = "Height" TextSave = "Height" Key = "" Object.Tag = "" EndProperty EndProperty End Begin ComctlLib.ImageList ImageList1 Left = 5400 Top = 960 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 21 ImageHeight = 21 MaskColor = 12632256 _Version = 327682 BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} NumListImages = 5 BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Preview.frx":0000 Key = "" EndProperty BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Preview.frx":018E Key = "" EndProperty BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Preview.frx":031C Key = "" EndProperty BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Preview.frx":04AA Key = "" EndProperty BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Preview.frx":0A3C Key = "" EndProperty EndProperty End Attribute VB_Name = "frmPreview" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '******************************************************************' '* *' '* TurboCAD for Windows *' '* Copyright (c) 1993 - 2001 *' '* International Microcomputer Software, Inc. *' '* (IMSI) *' '* All rights reserved. *' '* *' '******************************************************************' Option Explicit 'Global variables 'SDK objects Dim TheApp As Object Dim Drawings As Object Dim TheDrawing As Object Dim Views As Object Dim TheView As Object 'View parameters Dim ViewH#, ViewW#, ViewL#, ViewT# 'View coordinates 'Scroll parameters Dim ScrollCenterX#, ScrollCenterY# 'Dead center for scrolling Dim ScrollRangeX#, ScrollRangeY# 'Scroll range Dim HScrollLast%, VScrollLast% 'Remember last values for use in scrolling 'Drag and tool states Dim ActiveTool$ Dim StartX#, StartY# Dim LeftButtonDown As Boolean Dim Dragging As Boolean 'Curve tool Dim SplineGraphic As Object Dim SplineVerts As Object 'Select tool Dim SelectedGraphic As Object Dim SavedColor As Variant Private Sub OnNewDrawing() On Error GoTo Errors 'Update the status bar with new drawing name StatusBar1.Panels(1).Text = TheDrawing.Name Picture1.BackColor = RGB(255, 255, 255) Set Views = TheDrawing.Views Set TheView = Views.Add ViewW# = 0 ViewH# = 0 ViewL# = 0 ViewT# = 0 ViewZoomBy 0 Exit Sub Errors: ReleaseDrawingObjects End Sub Private Sub cmdDraw_Click() Repaint End Sub 'New button handler Private Sub cmdNew_Click() ReleaseDrawingObjects 'Close old drawing, etc. Set TheDrawing = Drawings.Add OnNewDrawing End Sub 'Open button handler Private Sub cmdOpen_Click() Dim FileName$ CommonDialog1.ShowOpen 'Get .tcw file name FileName$ = CommonDialog1.FileName If FileName$ = "" Then Exit Sub ReleaseDrawingObjects 'Close old drawing, etc. Set TheDrawing = Drawings.Open(FileName$) OnNewDrawing End Sub Private Sub cmdZoomMinus_Click() ViewZoomBy 0.707 End Sub Private Sub cmdZoomPlus_Click() ViewZoomBy 1.414 End Sub Private Sub Form_Load() On Error Resume Next 'Hide exceptions 'Connect to application server 'Use IMSIGX.Application.4 for inproc (DLL) server 'Use TurboCAD.Application.4 for local (EXE) server Set TheApp = CreateObject("IMSIGX.Application.4") If TheApp Is Nothing Then MsgBox "Could not start server. " & Err.Description & " Quitting." End Else Set Drawings = TheApp.Drawings If Drawings Is Nothing Then MsgBox "Bad server. " & Err.Description & " Quitting" End End If End If End Sub Private Function UnselectAll() As Boolean Dim PenColor As Object If Not (SelectedGraphic Is Nothing) Then Set PenColor = SelectedGraphic.Properties("PenColor") PenColor.Value = SavedColor Set SelectedGraphic = Nothing UnselectAll = True Else UnselectAll = False End If End Function Public Sub KillModes() If ActiveTool$ <> "" Then Toolbar1.Buttons(ActiveTool$).Value = tbrUnpressed ActiveTool$ = "" End If If UnselectAll Then Repaint Set SplineVerts = Nothing Set SplineGraphic = Nothing LeftButtonDown = False Dragging = False End Sub Public Sub ReleaseDrawingObjects() KillModes 'Update the status bar StatusBar1.Panels(1).Text = "No drawing" Set TheView = Nothing Set Views = Nothing Picture1.BackColor = vbWindowBackground If Not (TheDrawing Is Nothing) Then TheDrawing.Close Set TheDrawing = Nothing End If End Sub 'Painting Private Sub Repaint() Picture1.Refresh End Sub 'Zooming Private Sub ViewZoomBy(Factor#) TheView.Update = False TheView.hWnd = Picture1.hWnd TheView.MappingMode = 1 TheView.Margins = False TheView.FixedAspectRatio = True Dim ViewChanged As Boolean Dim ZoomIt As Boolean If Factor# <= 0# Or (ViewW# = 0 And ViewW# = 0) Then 'Factor# <= 0# means reset. Otherwise, initial settings TheView.ScreenLeft = Picture1.ScaleLeft TheView.ScreenTop = Picture1.ScaleTop TheView.ScreenWidth = Picture1.ScaleWidth TheView.ScreenHeight = Picture1.ScaleHeight ViewL# = TheView.ViewLeft ViewT# = TheView.ViewTop ViewW# = TheView.ViewWidth ViewH# = TheView.ViewHeight ZoomIt = True ViewChanged = True End If If Factor# > 0# And Factor <> 1# Then 'Keep the center fixed, and change the view coordinates Dim ViewCenterX#, ViewCenterY# ViewCenterX# = ViewL# + (ViewW# / 2#) ViewCenterY# = ViewT# - (ViewH# / 2#) ViewW# = ViewW# / Factor# ViewH# = ViewH# / Factor# ViewL# = ViewCenterX# - (ViewW# / 2#) ViewT# = ViewCenterY# + (ViewH# / 2#) ViewChanged = True End If 'Synchronize the view TheView.ViewLeft = ViewL# TheView.ViewTop = ViewT# TheView.ViewWidth = ViewW# TheView.ViewHeight = ViewH# If ZoomIt Then TheView.ZoomToExtents End If Repaint 'Update display If ViewChanged Then UpdateScrollParams End If End Sub Private Sub Form_Unload(Cancel As Integer) ReleaseDrawingObjects Set Drawings = Nothing Set TheApp = Nothing End Sub 'Scrolling Private Sub UpdateScrollParams() 'Min always 0 'Max always 32000 'LargeChange always 320 'SmallChange always 32 'Default values ScrollCenterX# = 0# ScrollCenterY# = 0# ScrollRangeX# = 1# ScrollRangeY# = 1# Dim X1#, Y1#, X2#, Y2# X1# = ViewL# Y1# = ViewT# - ViewH# X2# = ViewL# + ViewW# Y2# = ViewT# On Error GoTo Errors If Not (TheDrawing Is Nothing) Then 'Set scroll center to center of drawing's 'X-Y bounding box Dim Graphics As Object Dim BBox As Object Dim BoxMin As Object Dim BoxMax As Object Set Graphics = TheDrawing.Graphics Set BBox = Graphics.CalcBoundingBox Set BoxMin = BBox.Min Set BoxMax = BBox.Max X1# = BoxMin.X Y1# = BoxMin.Y X2# = BoxMax.X Y2# = BoxMax.Y ScrollCenterX# = (X1# + X2#) / 2# ScrollCenterY# = (Y1# + Y2#) / 2# 'Expand bounding box to include current viewport If ViewL# < X1# Then X1# = ViewL# If (ViewT# - ViewH#) < Y1# Then Y1# = ViewT# - ViewH# If (ViewL# + ViewW#) > X2# Then X2# = ViewL# + ViewW# If ViewT# > Y2# Then Y2# = ViewT# End If Errors: 'Now set scroll range based on bounding box Dim Delta1#, Delta2# 'Either side of center Delta1# = ScrollCenterX# - X1# Delta2# = X2# - ScrollCenterX# If Delta1# > Delta2# Then ScrollRangeX# = 2# * Delta1# Else ScrollRangeX# = 2# * Delta2# End If Delta1# = ScrollCenterY# - Y1# Delta2# = Y2# - ScrollCenterY# If Delta1# > Delta2# Then ScrollRangeY# = 2# * Delta1# Else ScrollRangeY# = 2# * Delta2# End If 'Update controls with these values SetScrollValues End Sub 'Update HScroll1 and VScroll1 controls with global values Private Sub SetScrollValues() Dim ScrollVal% Dim DValue#, DMax# 'Scrollbar value, max as doubles Dim ViewC# 'Center of view 'We set the values proportionally If ScrollRangeX# > 0# Then DMax# = HScroll1.Max ViewC# = ViewL# + (ViewW# / 2#) DValue# = (DMax# / 2#) + DMax# * (ViewC# - ScrollCenterX#) / ScrollRangeX# If DValue# < 0# Then ScrollVal% = 0 ElseIf DValue# > DMax# Then ScrollVal% = HScroll1.Max Else ScrollVal% = DValue# End If Else ScrollVal% = (HScroll1.Min + HScroll1.Max) / 2 End If HScroll1.Value = ScrollVal% HScrollLast% = ScrollVal% 'Remember last value If ScrollRangeY# > 0# Then DMax# = VScroll1.Max ViewC# = ViewT# - (ViewH# / 2#) DValue# = (DMax# / 2#) + DMax# * (ViewC# - ScrollCenterY#) / ScrollRangeY# If DValue# < 0# Then ScrollVal% = 0 ElseIf DValue# > DMax# Then ScrollVal% = VScroll1.Max Else ScrollVal% = DValue# End If Else ScrollVal% = (VScroll1.Min + VScroll1.Max) / 2 End If VScroll1.Value = ScrollVal% VScrollLast% = ScrollVal% 'Remember last value End Sub 'Change the viewport parameters after a scroll Private Sub ViewScrollBy(DeltaX#, DeltaY#) ViewL# = ViewL# + DeltaX# ViewT# = ViewT# + DeltaY# ViewZoomBy 1# End Sub Private Sub UpdateHScroll() Dim ScrollVal% ScrollVal% = HScroll1.Value If (ScrollVal% <> HScrollLast%) And Not (TheDrawing Is Nothing Or TheView Is Nothing) Then Dim Range# Dim Delta# Range# = HScroll1.Max - HScroll1.Min Delta# = ScrollVal% - HScrollLast% Delta# = Delta# * ViewW# / Range# ViewScrollBy Delta#, 0# End If HScrollLast% = ScrollVal% 'Remember last value End Sub Private Sub UpdateVScroll() Dim ScrollVal% ScrollVal% = VScroll1.Value If (ScrollVal% <> VScrollLast%) And Not (TheDrawing Is Nothing Or TheView Is Nothing) Then Dim Range# Dim Delta# Range# = VScroll1.Max - VScroll1.Min Delta# = ScrollVal% - VScrollLast% Delta# = -Delta# * ViewH# / Range# ViewScrollBy 0#, Delta# End If VScrollLast% = ScrollVal% 'Remember last value End Sub 'Scroll handlers Private Sub HScroll1_Change() UpdateHScroll End Sub Private Sub HScroll1_Scroll() UpdateHScroll End Sub Private Function MyFormat(Val#) As String Dim Log10# Log10# = Log(Abs(Val#)) / Log(10#) If (Log10# > 5#) Or (Log10# < -3#) Then MyFormat = Format(Val#, "0.00E-00") Else MyFormat = Format(Val#, "0.0###") End If End Function Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If (Button And 1) = 0 Then Exit Sub 'Only care about left button Dragging = False LeftButtonDown = True Dim NeedRepaint As Boolean Dim PickResult As Object Dim PickCount% Dim PenColor As Object 'Property object Dim Graphics As Object Dim CurX#, CurY# On Error GoTo Errors If Not (TheDrawing Is Nothing Or TheView Is Nothing) Then CurX# = X CurY# = Y TheView.ScreenToView CurX#, CurY#, StartX#, StartY# Select Case ActiveTool$ Case "Star" Set Graphics = TheDrawing.Graphics Graphics.AddStar StartX#, StartY#, 0# Case "Select" Set PickResult = TheView.PickPoint(StartX#, StartY#, 0.1) PickCount% = PickResult.Count NeedRepaint = UnselectAll If PickCount% > 0 Then Set SelectedGraphic = PickResult(0).Graphic Set PenColor = SelectedGraphic.Properties("PenColor") SavedColor = PenColor.Value PenColor.Value = &HFF00FF 'Magenta NeedRepaint = True End If If NeedRepaint Then Repaint End Select End If Errors: End Sub Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If (Button And 1) = 0 Then Exit Sub 'Only care about left button If Not LeftButtonDown Then Exit Sub 'Only if left button was down Dragging = True End Sub Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If (Button And 1) = 0 Then Exit Sub 'Only care about left button If Not LeftButtonDown Then Exit Sub Dim Graphics As Object Dim CurX#, CurY# Dim VX#, VY# 'Mouse coordinates in view space On Error GoTo Errors If Not (TheDrawing Is Nothing Or TheView Is Nothing) Then Set Graphics = TheDrawing.Graphics If ActiveTool$ <> "" Then CurX# = X CurY# = Y TheView.ScreenToView CurX#, CurY#, VX#, VY# Select Case ActiveTool$ Case "Circle" Graphics.AddCircleCenterAndPoint StartX#, StartY#, 0#, VX#, VY#, 0# TheView.Update = True Case "Line" Graphics.AddLineSingle StartX#, StartY#, 0#, VX#, VY#, 0# TheView.Update = True Case "Curve" If SplineGraphic Is Nothing Then Set SplineGraphic = Graphics.AddCurveSpline(StartX#, StartY#, 0#) Set SplineVerts = SplineGraphic.Vertices End If If Not (SplineVerts Is Nothing) Then SplineVerts.Add VX#, VY#, 0# Repaint Case Else End Select End If End If Set Graphics = Nothing LeftButtonDown = False Dragging = False Exit Sub Errors: Set SplineVerts = Nothing Set SplineGraphic = Nothing Set Graphics = Nothing LeftButtonDown = False Dragging = False End Sub Private Sub Picture1_Paint() If Not (TheView Is Nothing) Then TheView.Update = False TheView.hWnd = Picture1.hWnd TheView.MappingMode = 1 TheView.Margins = False TheView.FixedAspectRatio = True If (ViewW# = 0#) And (ViewH# = 0#) Then 'Initial settings TheView.ScreenLeft = Picture1.ScaleLeft TheView.ScreenTop = Picture1.ScaleTop TheView.ScreenWidth = Picture1.ScaleWidth TheView.ScreenHeight = Picture1.ScaleHeight TheView.ZoomToExtents Else 'Saved settings TheView.Refresh End If 'Update globals ViewL# = TheView.ViewLeft ViewT# = TheView.ViewTop ViewW# = TheView.ViewWidth ViewH# = TheView.ViewHeight 'Feedback in status bar StatusBar1.Panels(2).Text = MyFormat(ViewL#) StatusBar1.Panels(3).Text = MyFormat(ViewT#) StatusBar1.Panels(4).Text = MyFormat(ViewW#) StatusBar1.Panels(5).Text = MyFormat(ViewH#) Else 'Feedback in status bar StatusBar1.Panels(2).Text = "Left" StatusBar1.Panels(3).Text = "Top" StatusBar1.Panels(4).Text = "Width" StatusBar1.Panels(5).Text = "Height" End If End Sub Private Sub Toolbar1_ButtonClick(ByVal Button As Button) KillModes ActiveTool$ = Button.Key End Sub Private Sub VScroll1_Change() UpdateVScroll End Sub Private Sub VScroll1_Scroll() UpdateVScroll End Sub